home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Source Code / By the Book / Mac Pascal Primer, 4.0 / Chap 7, PrintPICT ƒ / PrintPICT.p < prev    next >
Text File  |  1990-06-22  |  3KB  |  144 lines
  1. program PrintPICT;
  2.     uses
  3.         Printing;
  4.  
  5.     const
  6.         HEADER_SIZE = 512;
  7.         BASE_RES_ID = 400;
  8.  
  9.         ERROR_ALERT_ID = BASE_RES_ID;
  10.         CANT_OPEN_FILE = BASE_RES_ID;
  11.         GET_EOF_ERROR = BASE_RES_ID + 1;
  12.         HEADER_TOO_SMALL = BASE_RES_ID + 2;
  13.         OUT_OF_MEMORY = BASE_RES_ID + 3;
  14.         CANT_READ_HEADER = BASE_RES_ID + 4;
  15.         CANT_READ_PICT = BASE_RES_ID + 5;
  16.  
  17.         NIL_STRING = '';
  18.         IGNORED_STRING = NIL_STRING;
  19.         HOPELESSLY_FATAL_ERROR = 'Game over, man!';
  20.  
  21.     var
  22.         gPrintRecordH: THPrint;
  23.         gReply: SFReply;
  24.  
  25.  
  26. {-------------------------------->    ErrorHandler    <---}
  27.  
  28.     procedure ErrorHandler (stringNum: INTEGER);
  29.         var
  30.             errorStringH: StringHandle;
  31.             dummy: INTEGER;
  32.     begin
  33.         errorStringH := GetString(stringNum);
  34.         if errorStringH = nil then
  35.             ParamText(HOPELESSLY_FATAL_ERROR, NIL_STRING, NIL_STRING, NIL_STRING)
  36.         else
  37.             ParamText(errorStringH^^, NIL_STRING, NIL_STRING, NIL_STRING);
  38.  
  39.         dummy := StopAlert(ERROR_ALERT_ID, nil);
  40.         ExitToShell;
  41.     end;
  42.  
  43.  
  44. {-------------------------------->    PrintPictFile    <---}
  45.  
  46.     procedure PrintPictFile (reply: SFReply);
  47.         var
  48.             srcFile: INTEGER;
  49.             printPort: TPPrPort;
  50.             printStatus: TPrStatus;
  51.             thePict: PicHandle;
  52.             pictHeader: packed array[0..HEADER_SIZE] of CHAR;
  53.             pictSize, headerSize: LONGINT;
  54.             dummy: OSErr;
  55.     begin
  56.         if (FSOpen(reply.fName, reply.vRefNum, srcFile) <> noErr) then
  57.             ErrorHandler(CANT_OPEN_FILE);
  58.  
  59.         if (GetEOF(srcFile, pictSize) <> noErr) then
  60.             ErrorHandler(GET_EOF_ERROR);
  61.  
  62.         headerSize := HEADER_SIZE;
  63.         if (FSRead(srcFile, headerSize, @pictHeader) <> noErr) then
  64.             ErrorHandler(CANT_READ_HEADER);
  65.  
  66.         pictSize := pictSize - HEADER_SIZE;
  67.         if pictSize <= 0 then
  68.             ErrorHandler(HEADER_TOO_SMALL);
  69.  
  70.         thePict := PicHandle(NewHandle(pictSize));
  71.         if thePict = nil then
  72.             ErrorHandler(OUT_OF_MEMORY);
  73.  
  74.         HLock(Handle(thePict));
  75.  
  76.         if FSRead(srcFile, pictSize, Ptr(thePict^)) <> noErr then
  77.             ErrorHandler(CANT_READ_PICT);
  78.  
  79.         dummy := FSClose(srcFile);
  80.  
  81.         printPort := PrOpenDoc(gPrintRecordH, nil, nil);
  82.         PrOpenPage(printPort, nil);
  83.         DrawPicture(thePict, thePict^^.picFrame);
  84.         PrClosePage(printPort);
  85.         PrCloseDoc(printPort);
  86.  
  87.         PrPicFile(gPrintRecordH, nil, nil, nil, printStatus);
  88.  
  89.         HUnlock(Handle(thePict));
  90.     end;
  91.  
  92.  
  93. {-------------------------------->    DoDialogs    <---}
  94.  
  95.     function DoDialogs: BOOLEAN;
  96.         var
  97.             keepGoing: BOOLEAN;
  98.     begin
  99.         keepGoing := PrStlDialog(gPrintRecordH);
  100.  
  101.         if keepGoing then
  102.             DoDialogs := PrJobDialog(gPrintRecordH)
  103.         else
  104.             DoDialogs := FALSE;
  105.     end;
  106.  
  107.  
  108. {-------------------------------->    GetFileName    <---}
  109.  
  110.     procedure GetFileName (var replyPtr: SFReply);
  111.         var
  112.             myPoint: Point;
  113.             typeList: SFTypeList;
  114.             numTypes: INTEGER;
  115.     begin
  116.         myPoint.h := 100;
  117.         myPoint.v := 100;
  118.         typeList[0] := 'PICT';
  119.         numTypes := 1;
  120.         SFGetFile(myPoint, IGNORED_STRING, nil, numTypes, typeList, nil, replyPtr);
  121.     end;
  122.  
  123.  
  124. {-------------------------------->    PrintInit    <---}
  125.  
  126.     procedure PrintInit;
  127.     begin
  128.         gPrintRecordH := THPrint(NewHandle(sizeof(TPrint)));
  129.         PrOpen;
  130.         PrintDefault(gPrintRecordH);
  131.     end;
  132.  
  133.  
  134. {-------------------------------->    PrintPICT    <---}
  135.  
  136. begin
  137.     PrintInit;
  138.     GetFileName(gReply);
  139.     if gReply.good then
  140.         begin
  141.             if DoDialogs then
  142.                 PrintPictFile(gReply);
  143.         end;
  144. end.